00100	SUBR(THRESH)------------------------------------------------------
00200	BEGIN THRESH;THRESHOLD(LEVEL) pre foonly version. BGB 4 DEC 1972.
00300		SKIPE FLGKRK↔DETSEG
00400	;SOUBIT TO PAC FOR PIXELS ≥ CUT.
00500		I←13 ↔ J←14
00600		CALL(SEGTV)
00700		LAC [XWD L,2]↔BLT 13
00800		LAC ARG1↔DAC HCUT
00900		LAP 5,ARG1
01000		GO 3
01100	
01200	;ACCUMULATOR LOOP.
01300	L:	POINT 6,TVBUF,-1
01400		MOVEI J,=36	;3
01500		ILDB 2		;4
01600		SUBI ;CUT	;5
01700		ROTC 1		;6
01800		SOJG J,4	;7
01900		SETCAM 1,PAC(I) ;10
02000		AOBJN I,3	;11
02100		POP1J		;12
02200		XWD -=1728,0	;13
02300	BEND;12/17/72-----------------------------------------------------
02400	
02500	HCUT:	0	;HCUT GLOBAL FROM THRESH TO MKPGONS.
02600	
02700	SUBR(PACXOR)------------------------------------------------------
02800	BEGIN PACXOR;do rook's exclusive OR'ing. BGB 4-DEC-72.
02900		I←2
03000		SLACI PAC↔LAPI HSEG↔BLT HSEG+=1727
03100		SLACI PAC↔LAPI VSEG↔BLT VSEG+=1727
03200		SETZ I,
03300		HRRI PAC↔DAP L+2
03400	L:	TRNN I,7↔SETZ 1,↔LAC PAC(I)
03500		XORM HSEG+8(I)	; HSEG SOUBIT are above PAC bits.
03600		ROTC -1↔ROT 1,1
03700		XORM VSEG(I)	; VSEG are left of PAC bits.
03800		AOS I
03900		CAIE I,=1728
04000		GO L
04100		SETZM ISAVED
04200		POP0J
04300	BEND;12/4/72------------------------------------------------------
04400	
     

00100	SUBR(HISTOG)---------------------------------------------------
00200	BEGIN HISTOG;MAKE HISTOGRAM OF TVBUF - BGB - 4 DEC 72.
00300	
00400		CALL(SEGTV)
00500		SKIPE FTVHIS↔POP0J↔SETOM FTVHIS
00600		LAC[XWD HISTO,HISTO+1]↔SETZM HISTO↔BLT HISTO+77
00700		LAC 7,[XWD L,0]↔BLT 7,6↔GO 2
00800	
00900	;ACCUMULATOR LOOP.
01000	L:	=62208		;0
01100		0		;1
01200		ILDB 1,6	;2
01300		AOS HISTO(1)	;3
01400		SOJG 0,2	;4
01500		POP0J		;5
01600		POINT 6,TVBUF,-1;6
01700	
01800	BEND;12/16/72-----------------------------------------------------
     

00100	SUBR(MKPGON)LEVEL--------------------------------------------------
00200	BEGIN MKPGON;MAKE AN INTENSITY CONTOUR POLYGON - BGB - AUGUST 1972.
00300	
00400		ACCUMULATORS{A2,A3,RC.,MASK,I,PTR,D,E,V,PG,BITQ,H1,H2}
00500		LAC H1,HCUT↔LSH H1,-3↔LACI H2,7↔SUB H2,H1
00600		LAC I,ISAVED↔CDR PTR,ARG1↔LACI BITQ,VREL
00700		SLACI I↔HRRI PAC↔DAC PACPTR#; PAC POINTER INDEXED BY I.
00800	
00900	;FIND THE ROW & COL OF THE UPPER LEFT MOST VSEG.
01000	L1:	SKIPE 1,VSEG(I)↔GO L2
01100		AOS I↔CAIE I,=1728↔GO L1
01200		SETZ 1,↔POP1J;EMPTY.
01300	
01400	L2:	DAC I,ISAVED↔JFFO 1,.+1↔SLACI MASK,400000
01500		MOVNS 2↔LSH MASK,(2)↔MOVNS 2
01600		LAC RC.,I↔ANDI RC.,7↔IMULI RC.,=36↔ADD RC.,2	;COLUMN.
01700		LAC I↔LSH -3↔DIP RC.↔LSH RC.,6			;ROW.
01800	
01900	;DISTINGUISH BLOBS FROM HOLES.
02000		SETZM HOLE#
02100		TDNN MASK,@PACPTR		;HOLE OR BLOB ?
02200		SETOM HOLE#			;HOLE'A'COMING.
02300		SKIPE HOLE↔EXCH H1,H2
02400	
02500	;AND HEAD SOUTH.
02600	
02700		SETQ(PG,{MAKE,[PBIT+PGNREL]})
02800		LAC 0,ARG1↔DAD. 0,PG↔CALL(RINGIN,PG,0)
02900		SKIPE HOLE↔GO[MARK PG,HOLBIT↔GO .+1]
03000		DAC  RC.,RCMIN#
03100		SETZM RCMAX#
03200		SETZ V,↔SETZM ECNT#
03300		PUSHJ P,FOLLOW
03400		LAC V,V0
03500		CCW. V,E↔CW. E,V
03600	
03700	;MAKE & RETURN VIC POLYGON.
03800	
03900		LAC 1,ECNT↔SKIPE HOLE#↔MOVNS 1
04000	 	NCNT. 1,PG
04100		LAC V0↔SON. 0,PG	;UPPER MOST LEFT.
04200	;	LAC V1↔ARC. 0,PG	;LOWER MOST RIGHT.
04300		LAC 1,PG
04400	L3:	POP1J
     

00100	;THE SUB-OPERATIONS OF MKPGON.
00200	
00300	DEFINE	TRY (SEG,YES) {
00400		LAC SEG(I)↔TDZN MASK↔GO .+3↔DAC SEG(I)↔GO YES}
00500	DEFINE	LEFT	{SUBI RC.,100↔ROT MASK,1↔CAIN MASK,1↔SOS I}
00600	DEFINE	RIGHT	{ADDI RC.,100↔ROT MASK,-1↔SKIPG MASK↔AOS I}
00700	DEFINE	UP 	{SUB RC.,[1B11]↔SUBI I,8}
00800	DEFINE	DOWN  	{ADD RC.,[1B11]↔ADDI I,8}
00900	
01000	;CREATE NEW EDGE AND VERTEX OF A VIC.
01100	TURN:	0
01200		AOS TURNS#
01300		ADD D,RC.
01400		AOS 2,ECNT
01500	
01600	;VERTEX
01700		CALL MAKE,BITQ
01800		PGON. PG,1
01900		SKIPN V↔GO[DAC 1,V0#↔DAC 1,V↔GO T2]
02000		DAC 1,V
02100		CCW. V,E↔CW. E,V
02200	T2:	DAC D,RC(V)
02300		CAMLE D,RCMAX
02400		GO[DAC D,RCMAX↔DAC V,V1#↔GO .+1]
02500		DAC V,E
02600		GO @TURN
     

00100	;THE ALCHEMIST OF MKPGON - converts bits of lead into lines of gold.
00200	
00300	NORTH:	ADD D,[1B11]↔LIPI BITQ,(NORBIT+VBIT)↔JSR TURN
00400	NORTH2:	LEFT↔LAC D,DELPM(H1)↔	TRY HSEG,WEST
00500		RIGHT↔UP↔	TRY VSEG,NORTH2
00600		DOWN↔LAC D,DELPP(H2)↔	TRY HSEG,EAST↔FATAL(NORTH)
00700	NORTH3:	LIPI BITQ,(NORBIT+VBIT)↔JSR TURN↔LEFT
00800	NORTH4:	UP↔LAC D,DELPM(H1)↔	TRY HSEG,WEST↔GO NORTH4
00900	
01000	
01100	WEST:	ADDI D,100↔LIPI BITQ,(WESBIT+VBIT)↔JSR TURN
01200	WEST2:	CAMN RC.,RCMIN↔POPJ P,;TRY FOR E.O.VIC.
01300	FOLLOW:	LAC D,DELPP(H1)↔	TRY VSEG,SOUTH
01400		LEFT↔		TRY HSEG,WEST2
01500		RIGHT↔UP↔LAC D,DELMP(H2)↔TRY VSEG,NORTH↔FATAL(WEST)
01600	
01700	
01800	SOUTH:	LIPI BITQ,(SOUBIT+VBIT)↔JSR TURN
01900	SOUTH2:	DOWN↔LAC D,DELMP(H1)
02000		CAR RC.↔CAIN =216B29↔GO EAST3
02100				TRY HSEG, EAST
02200				TRY VSEG,SOUTH2
02300		LEFT↔LAC D,DELMM(H2)↔	TRY HSEG,WEST↔	FATAL(SOUTH)
02400	
02500	
02600	EAST:	LIPI BITQ,(EASBIT+VBIT)↔JSR TURN
02700	EAST2:	RIGHT↔LAC D,DELMM(H1)
02800		CDR RC.↔CAIN =288B29↔GO NORTH3
02900		UP↔		TRY VSEG,NORTH
03000		DOWN↔		TRY HSEG,EAST2
03100		LAC D,DELPM(H2)↔	TRY VSEG,SOUTH↔FATAL(EAST)
03200	EAST3:	LIPI BITQ,(EASBIT+VBIT)↔JSR TURN↔UP
03300	EAST4:	RIGHT↔LAC D,DELMM(H1)
03400		CDR RC.↔CAIN =288B29↔GO[DOWN↔GO NORTH3]
03500				TRY VSEG,NORTH↔GO EAST4
03600	
03700	;DEKINKING OFF SETS.
03800		DELPP:	FOR I←24,33{XWD I,I↔}
03900		DELPM:	FOR I←24,33{XWD I,-I↔}
04000		DELMP:	FOR I←24,33{XWD -I,I↔}
04100		DELMM:	FOR I←24,33{XWD -I,-I↔}
04200	
04300	BEND;12/14/72-----------------------------------------------------